• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Macro aanpassen voor kopiëren tabbladen naar een gesloten bestand

Status
Niet open voor verdere reacties.
S

samabert

Gebruiker
Lid geworden
27 mrt 2010
Berichten
301
Goedenavond iedereen,

Bedoeling is om van bepaalde tabbladen in een open bestand (Test) bij het sluiten automatisch een kopie te maken naar een ander gesloten beveiligd bestand.
De bijgevoegde code werkt voor een enkel tabblad, dus de kopie wordt gemaakt naar het gesloten bestand zonder problemen.

Probleem: Graag zou ik de code aangepast zien dat dit niet voor 1 tabblad is maar voor meerdere tabbladen en dat de kopie dus ook zo wordt geplaatst in het gesloten bestand.
In de bijgevoegde code zie je om welke tabbladen het gaat.
Code: 
Sub Kopie()
    
    Dim wbDst As Workbook
    Dim rngSrc As Range
    Dim rngDst As Range

    Application.ScreenUpdating = False

    Set rngSrc = Sheets("JAN").Range("A1:AL29")
       'Dit moet voor ("JAN"),("FEB"),("MRT),("APR"),("MEI"),("JUN"),("JUL"),("AUG"),("SEP"),("OKT"),("NOV"),("DEC"),Range("A1:AL29")

    Set wbDst = Workbooks.Open("\\SERVER-BAMG7PMH\Exel\Hrs\Backup1.xlsm")
    'Backup1.xlsm is de naam van het werkboek waarnaar gekopieerd moet worden


    With wbDst.Sheets("JAN")
        'Dit moet ook worden: ("JAN"),("FEB"),("MRT),("APR"),("MEI"),("JUN"),("JUL"),("AUG"),("SEP"),("OKT"),("NOV"),("DEC")


        .Unprotect

        Set rngDst = .Range("A" & Rows.Count).End(xlUp).Offset(3)
        rngSrc.Copy

        rngDst.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
                            SkipBlanks:=False, Transpose:=False


        .Protect


    End With

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    wbDst.Close savechanges:=True

End Sub

Ik ben aan het zoeken geweest op iets met Array maar ik loop vast.
For Each ws In Sheets(Array("XTR", "VIP1", "VIP2"))

Graag jullie hulp hierbij.

Alvast bedankt.

Mvg.
Marc
 

Bijlagen

  • Test.xlsm
    55,5 KB · Weergaven: 32
Probeer deze:
Code: 
Sub Kopie()
    Dim wbDst As Workbook
    Dim Br

    Application.ScreenUpdating = False
    Set wbDst = Workbooks.Open("\\SERVER-BAMG7PMH\Exel\Hrs\Backup1.xlsm")
    For Each Br In Application.GetCustomListContents(3)
        With wbDst.Sheets(Br)
            .Unprotect
            ThisWorkbook.Sheets(Br).Range("A1:AL29").Copy .Range("A" & Rows.Count).End(xlUp).Offset(3)
            .Protect
        End With
    Next
    Application.ScreenUpdating = True
    wbDst.Close True
End Sub
 
Laatst bewerkt:
Timshel,

Bedankt voor je reactie.

Ik heb de code getest en deze werkt, de kopie wordt geplaatst.
Doch twee zaken die ik opgemerkt heb:

1/ Na het kopiëren en je gaat in het backup1 bestand kijken hoe de kopie eruit ziet krijg je telkens de vraag of je de koppeling wil bijwerken.
Heeft volgende daar iets mee te maken? In (Test) cel A3 op tabblad “JAN” komt bij een wijziging de datum en tijd te staan en deze wordt op elk andere blad gelinkt via JAN!A3. Als de kopie gemaakt is verschijnt alleen de tijd op JAN en bij FEB zie je dat hij verwijst naar ='C:\Users\Marc\Documents\MBE\Helpmij\[Test.xlsm]JAN'!A241.

2/ In de code die ik eerst postte , maar dan voor een enkel tabblad, werd als je het bestand (Test) sloot ging Backup1 niet even open om de kopie te plakken en dit zie je nu wel.
Geeft dit geen problemen als Test op een lokale pc staat en het Backup bestand op een server?

Misschien ook nog belangrijk om te vermelden, in het uiteindelijke bestand (Test) staan ook verborgen tabbladen buiten JAN,FEB enz. op.

Ik hoop dat je aan mijn uitleg iets hebt.
Mvg.
Marc
 
Laatst bewerkt:
Voeg de blauwe coderegel eens toe.
Code: 
[COLOR=#0000ff] wbDst.ChangeLink ThisWorkbook.FullName, wbDst.FullName, xlExcelLinks[/COLOR]
 wbDst.Close True
 
@ HSV,

Ik heb die regel bijgeplaatst in de code.
Code: 
Sub Kopie()
    Dim wbDst As Workbook
    Dim Br

    Application.ScreenUpdating = False
    Set wbDst = Workbooks.Open("\\SERVER-BAMG7PMH\Exel\Hrs\Backup1.xlsm")
    For Each Br In Application.GetCustomListContents(3)
        With wbDst.Sheets(Br)
            '.Unprotect
            ThisWorkbook.Sheets(Br).Range("A1:AL29").Copy .Range("A" & Rows.Count).End(xlUp).Offset(3)
            '.Protect
        End With
    Next

    Application.ScreenUpdating = True

    wbDst.ChangeLink ThisWorkbook.FullName, wbDst.FullName, xlExcelLinks
    wbDst.Close True

End Sub
Ik heb het veelvuldig getest en merk het volgende op:

Elke keer dat het bestand effectief wordt weggeschreven naar het Backup1 bestand en je geen VBA foutmelding krijgt op het bron bestand (Test_09_01_2017) en bij openen Backup1 bestand komt de melding van koppeling naar andere gegevensbronnen. Zelfs als je kiest voor niet bijwerken is de kopie toch volledig. Dit is dus als het bronbestand (Test) gesloten is.

Bij een volgende test krijg je direct een foutmelding op de nieuwe regel die je mij hebt laten invoegen, als je dan Backup1 opent krijg je geen melding van een koppeling naar andere gegevensbronnen. Bronbestand (Test) is hierbij ook gesloten.
Bij deze test, als je eerst de VBA fout weg klikt is de kopie naar het Backup1 bestand toch volledig.
De VBA fout die je als melding krijgt is: Methode ChangeLink van object_Workbook is mislukt.

Elke keer je het Backup1 bestand opent krijg je de melding van koppeling naar andere gegevensbronnen. Indien het bronbestand (Test) open staat krijg deze melding niet maar dat lijkt mij logisch.

Ik heb de protectie van het Backup1 bestand uitgeschakeld omdat ik wou weten of er daar problemen mee waren, dit heeft niets meer opgeleverd.

Ik hoop dat het een beetje duidelijk beschreven is?

Toch weer bedankt voor het aanbieden van een oplossing.
Mvg
Marc
 

Bijlagen

  • Test_09_01_2017.xlsm
    61,5 KB · Weergaven: 20
  • Backup1.xlsm
    59,5 KB · Weergaven: 24
Marc,

Gooi dat bestand in de prullenbak en maak een nieuwe.
Als je de koppeling wilt verwijderen komt het met een bericht: "Fout: Kan bron niet vinden".
Ga je het geforceerd verwijderen dan crasht Excel.

Ik heb de code getest in een schoon bestand, en dan werkt alles naar behoren met de code van @Timshel zonder de regelcode van mij.
 
Harry,

Bedankt dat je tijd hebt genomen om dit verder uit te spitten, sorry voor het crashen. :eek:
Nieuw bestand gemaakt en inderdaad het werkt zoals het moet en zonder fouten, Super!!!

Iets wat ik voorlopig nog graag aangepast wou hebben is volgende:

Bij het sluiten van het basis bestand (Test) met het rode kruisje start de macro kopie naar het Backup bestand, tot zover alles ok. Maar daarna krijg je de vraag of je het bestand (Test) wil opslaan of niet. Hier had ik graag dat Excel (applicatie) zelf volledig sluit zonder de vraag opslaan of niet. Maar dus wel degelijk opgeslagen.
Ik ben wat aan het stoeien geweest maar niets van dat blijkt te lukken, kan dit eigenlijk wel of sla ik de bal volledig mis?

Hier de code in ThisWorkbook:
Code: 
Option Explicit
Option Compare Text
Dim ws As Worksheet
Const MaxUses As Long = 15   '<- change users
Const wsWarningSheet As String = "Splash"
Private Sub Workbook_BeforeClose(Cancel As Boolean)

    On Error Resume Next

    ToevoegenActie False, sUser
    Application.DisplayAlerts = False
    Call Kopie ' Dit start de code van Timshel die de Kopie naar Backup1 maakt
    Application.Save
    

    Application.DisplayAlerts = True


    For Each ws In ThisWorkbook.Sheets
        If ws.Name = wsWarningSheet Then
            ws.Visible = True
        Else
            ws.Visible = xlVeryHidden
        End If
    Next

    With Sheets(wsWarningSheet).Cells(Rows.Count, Columns.Count)
        .Value = .Value + 1

    End With


End Sub



Private Sub Workbook_Open()
 'this line should only be used in the example
    Sheet7.Visible = xlSheetVisible
    frmPW.Show
   
End Sub

Met de aanpassingen die je voor mij tot hiertoe al gemaakt hebt ben ik heel blij! :thumb:
Mvg.
Marc
 
Code: 
thisworkbook.save
net boven 'End Sub'.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan